home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir44
/
advsrc.zip
/
ADVENTUR.FOR
< prev
next >
Wrap
Text File
|
1993-07-29
|
82KB
|
2,355 lines
c =====================================================================
c Adventure!
c =====================================================================
c Modified for MS DOS PDS FORTRAN v5.10
c by Paul Muñoz-Colman, FunStuff Software
c 27 Mar 1993 change date & time to getdat & gettim
c delete DO66 and DEBUG metacommands
c change pause prompt
c change OPEN STATUS to UNKNOWN on overwrites
c 15 Oct 1990 fix abort in line 653 from using the "say" verb
c 13 Oct 1987 with suspend and resume feature--2-byte storage
c =====================================================================
c
c Differences from Honeywell version to live with MS FORTRAN 77:
c 1. Can't EQUIVALENCE anything in COMMON or storage is bad.
c 2. LOGICAL functions can't have integer arguments--doesn't work.
c All were rewritten to be INTEGER functions (1=true,0=false)
c 3. Data Base is binary file written by separate program to
c save space and time. Limited to 64K. I/O is slowww...
c 4. SAVE feature saves data arrays instead of whole program.
c RESUME must be given first turn, which reads file.
c 5. Demonstration game and wizard stuff is gone...stupid anyway..
c
c Current limits:
c 21150 words of message text (lines, linsiz)
c 745 travel options (travel, trvsiz).
c 295 vocabulary words (ktab, atab, tabsiz).
c 150 locations (ltext, stext, key, cond, abb, atloc, locsiz).
c 100 objects (plac, place, fixd, fixed, link (twice), ptext, prop)
c 35 "action" verbs (actspk, vrbsiz).
c 205 random messages (rtext, rtxsiz).
c 12 different player classifications (ctext, cval, clsmax).
c 20 hints, less 3 (hintlc, hinted, hints, hntsiz).
c
c there are also limits which cannot be exceeded due to the structure of
c the database. (e.g., the vocabulary uses n/1000 to determine word type,
c so there can't be more than 1000 words.) these upper limits are:
c 1000 non-synonymous vocabulary words
c 300 locations
c 100 objects
c
c set metacommands for ms fortran
$nodebug
$notstrict
$storage: 2
c
implicit integer*2 (a-z)
c
common /txtcom/ rtext
common /blkcom/ blklin
common /voccom/ ktab,atab,tabsiz
common /placom/ atloc,link,place,fixed,holdng
common /ptxcom/ ptext
common /abbcom/ abb
common /concom/ cond
common /loccom/ loc
common /procom/ prop, lamp
common /lincom/ lines
character*2 lines (21150)
character*4 wd1,wd2,iz,bl,atab(295),wd1x,wd2x
character*1 tk(20)
c
integer*2 ktab(295),rtext(205),atloc(150)
integer*2 ltext(150),stext(150),key(150),cond(150),abb(150)
integer*2 plac(100),place(100),fixd(100),fixed(100),link(200)
integer*2 actspk(35),ptext(100),prop(100),ctext(12),cval(12)
integer*2 hintlc(20),hinted(20),hints(20,4),dseen(6),dloc(6)
integer*2 idondx,odloc(6)
integer*4 travel(745),itk(20),newloc,linuse,kk,linsiz
integer*4 ll,izz
c
equivalence(izz,iz)
c
external ran
c
data linsiz/21150/,trvsiz/745/,locsiz/150/,izz/0/,
. vrbsiz/35/,rtxsiz/205/,clsmax/12/,hntsiz/20/
data bl/' '/
c
c various functions--all integer in ms fortran--1 true 0 false
c some are statement functions--others independently compiled
bitset(l,n)=mod(shift(cond(l),-n),2)
liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil)
liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1)
liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle)))
c
c toting(obj) = true if the obj is being carried
c here(obj) = true if the obj is at "loc" (or is being carried)
c at(obj) = true if on either side of two-placed object
c liq(dummy) = object number of liquid in bottle
c liqloc(loc) = object number of liquid (if any) at loc
c bitset(l,n) = true if cond(l) has bit n set (bit 0 is units bit)
c forced(loc) = true if loc moves without asking for input (cond=2)
c dark(dummy) = true if location "loc" is dark
c pct(n) = true n% of the time (n integer*2 from 0 to 100)
c wzdark says whether the loc he's leaving was dark
c lmwarn says whether he's been warned about lamp going dim
c closng says whether its closing time yet
c panic says whether he's found out he's trapped in the cave
c closed says whether we're all the way closed
c gaveup says whether he exited via "quit"
c scorng indicates to the score routine whether we're doing a "score" command
c yea is random yes/no reply
c description of the database format
c the data file contains several sections. each begins with a line containing
c a number identifying the section, and ends with a line containing "-1".
c
c section 1: long form descriptions. each line contains a location number,
c and a line of text. the set of (necessarily adjacent) lines
c whose numbers are x form the long description of location x.
c
c section 2: short form descriptions. same format as long form. not all
c places have short descriptions.
c
c section 3: travel table. each line contains a location number (x), a second
c location number (y), and a list of motion numbers (see section 4).
c each motion represents a verb which will go to y if currently at x.
c y, in turn, is interpreted as follows. let m=y/1000, n=y mod 1000.
c if n<=300 it is the location to go to.
c if 300<n<=500 n-300 is used in a computed goto to
c a section of special code.
c if n>500 message n-500 from section 6 is printed,
c and he stays wherever he is.
c meanwhile, m specifies the conditions on the motion.
c if m=0 it's unconditional.
c if 0<m<100 it is done with m% probability.
c if m=100 unconditional, but forbidden to dwarves.
c if 100<m<=200 he must be carrying object m-100.
c if 200<m<=300 must be carrying or in same room as m-200.
c if 300<m<=400 prop(m mod 100) must *not* be 0.
c if 400<m<=500 prop(m mod 100) must *not* be 1.
c if 500<m<=600 prop(m mod 100) must *not* be 2, etc.
c
c if the condition (if any) is not met, then the next *different*
c "destination" value is used (unless it fails to meet *its* conditions,
c in which case the next is found, etc.). typically, the next dest will
c be for one of the same verbs, so that its only use is as the alternate
c destination for those verbs. for instance:
c 15 110022 29 31 34 35 23 43
c 15 14 29
c this says that, from loc 15, any of the verbs 29, 31, etc1. will take
c him to 22 if he's carrying object 10, and otherwise will go to 14.
c 11 303008 49
c 11 9 50
c this says that, from 11, 49 takes him to 8 unless prop(3)=0, in which
c case he goes to 9. verb 50 takes him to 9 regardless of prop(3).
c
c section 4: vocabulary. each line contains a number (n), and a
c five-letter word. call m=n/1000. if m=0, then the word is a motion
c verb for use in travelling (see section 3). else, if m=1, the word is
c an object. else, if m=2, the word is an action verb (such as "carry"
c or "attack"). else, if m=3, the word is a special case verb (such as
c "dig") and n mod 1000 is an index into section 6. objects from 50 to
c (currently, anyway) 79 are considered treasures (for pirate, closeout).
c
c section 5: object descriptions. each line contains a number (n),
c and a message. if n is from 1 to 100, the message is the "inventory"
c message for object n. otherwise, n should be 000, 100, 200, etc., and
c the message should be the description of the preceding object when its
c prop value is n/100. the n/100 is used only to distinguish multiple
c messages from multi-line messages; the prop info actually requires all
c messages for an object to be present and consecutive. properties which
c produce no message should be given the message ">$<".
c
c section 6: arbitrary messages. same format as sections 1, 2, and 5, except
c the numbers bear no relation to anything (except for special verbs
c in section 4).
c
c section 7: object locations. each line contains an object number and its
c initial location (zero (or omitted) if none). if the object is
c immovable, the location is followed by a "-1". if it has two locations
c (e.g. the grate) the first location is followed with the second, and
c the object is assumed to be immovable.
c
c section 8: action defaults. each line contains an "action-verb" number and
c the index (in section 6) of the default message for the verb.
c
c section 9: liquid assets, etc. each line contains a number (n) and up to 20
c location numbers. bit n (where 0 is the units bit) is set in cond(loc)
c for each loc given. the cond bits currently assigned are:
c 0 light
c 1 if bit 2 is on: on for oil, off for water
c 2 liquid asset, see bit 1
c 3 pirate doesn't go here unless following player
c other bits are used to indicate areas of interest to "hint" routines:
c 4 trying to get into cave
c 5 trying to catch bird
c 6 trying to deal with snake
c 7 lost in maze
c 8 pondering dark room
c 9 at witt's end
c cond(loc) is set to 2, overriding all other bits, if loc has forced
c motion.
c
c section 10: class messages. each line contains a number (n), and a
c message describing a classification of player. the scoring section
c selects the appropriate message, where each message is considered to
c apply to players whose scores are higher than the previous n but not
c higher than this n. note that these scores probably change with every
c modification (and particularly expansion) of the program.
c
c section 11: hints. each line contains a hint number (corresponding to a
c cond bit, see section 9), the number of turns he must be at the right
c loc(s) before triggering the hint, the points deducted for taking the
c hint, the message number (section 6) of the question, and the message
c number of the hint. these values are stashed in the "hints" array.
c hntmax is set to the max hint number (<= hntsiz). numbers 1-3 are
c unusable since cond bits are otherwise assigned, so 2 is used to
c remember if he's read the clue in the repository, and 3 is used to
c remember whether he asked for instructions (gets more turns, but loses
c points).
c
c section 12: magic messages. not implemented ibm pc version. stupid.
c
c section 0: end of database.
c
c clear out the various text-pointer arrays. all text is stored in array
c lines; each line is preceded by a word pointing to the next pointer (i.e.
c the word following the end of the line). the pointer is negative if this is
c first line of a message. the text-pointer arrays contain indices of
c pointer-words in lines. stext(n) is short description of location n.
c ltext(n) is long description. ptext(n) points to message for prop(n)=0.
c successive prop messages are found by chasing pointers. rtext contains
c section 6's stuff. ctext(n) points to a player-class message.
c we also clear cond. see description of section 9 for details.
c
c the stuff for section 3 is encoded here. each "from-location" gets a
c contiguous section of the "travel" array. each entry in travel is
c newloc*1000 + keyword (from section 4, motion verbs), and is negated if
c this is the last entry for this location. key(n) is the index in travel
c of the first option at location n.
c here we read in the vocabulary. ktab(n) is the word number, atab(n) is
c the corresponding word. the -1 at the end of section 4 is left in ktab
c as an end-marker.
c read in the initial locations for each object. also the immovability info.
c plac contains initial locations of objects. fixd is -1 for immovable
c objects (including the snake), or = second loc for two-placed objects.
c read default message numbers for action verbs, store in actspk.
c read info about available liquids and other conditions, store in cond.
c read data for hints.
c having read in the database, certain things are now constructed. props are
c set to zero. we finish setting up cond by checking for forced-motion travel
c entries. the plac and fixd arrays are used to set up atloc(n) as the first
c object at location n, and link(obj) as the next object at the same location
c as obj. (obj>100 indicates that fixed(obj-100)=loc; link(obj) is still the
c correct link to use.) abb is zeroed; it controls whether the abbreviated
c description is printed. counts mod 5 unless "look" is used.
c set up the atloc and link arrays as described above. we'll use the drop
c suboutine, which prefaces new objects on the lists. since we want things
c in the other order, we'll run the loop backwards. if the object is in two
c locs, we drop it twice. this also sets up "place" and "fixed" as copies of
c "plac" and "fixd". also, since two-placed objects are typically best
c described last, we'll drop them first.
c treasures, as noted earlier, are objects 50 through maxtrs (currently 79).
c their props are initially -1, and are set to 0 the first time they are
c described. tally keeps track of how many are not yet found, so we know
c when to close the cave. tally2 counts how many can never be found (e.g. if
c lost bird or bridge).
c clear the hint stuff. hintlc(i) is how long he's been at loc with cond bit
c i. hinted(i) is true iff hint i has been used.
c define some handy mnemonics. these correspond to object numbers.
c objects from 50 through whatever are treasures. here are a few.
c these are motion-verb numbers.
c and some action verbs.
c initialize the dwarves. dloc is loc of dwarves, hard-wired in. odloc is
c prior loc of each dwarf, initially garbage. daltlc is alternate initial loc
c for dwarf, in case one of them starts out on top of the adventurer. (no 2
c of the 5 initial locs are adjacent.) dseen is true if dwarf has seen him.
c dflag controls the level of activation of all this:
c 0 no dwarf stuff yet (wait until reaches hall of mists)
c 1 reached hall of mists, but hasn't met first dwarf
c 2 met first dwarf, others start moving, no knives thrown yet
c 3 a knife has been thrown (first set always misses)
c 3+ dwarves are mad (increases their accuracy)
c sixth dwarf is special (the pirate). he always starts at his chest's
c eventual location inside the maze. this loc is saved in chloc for ref.
c the dead end in the other maze has its loc stored in chloc2.
c other random flags and counters, as follows:
c turns tallies how many commands he's given (ignores yes/no)
c limit lifetime of lamp (not set here)
c iwest how many times he's said "west" instead of "w"
c knfloc 0 if no knife here, loc if knife here, -1 after caveat
c detail how often we've said "not allowed to give more detail"
c abbnum how often we should print non-abbreviated descriptions
c maxdie number of reincarnation messages available (up to 5)
c numdie number of times killed so far
c holdng number of objects being carried
c dkill number of dwarves killed (unused in scoring, needed for msg)
c foobar current progress in saying "fee fie foe foo".
c bonus used to determine amount of bonus if he reaches closing
c clock1 number of turns from finding last treasure till closing
c clock2 number of turns from first warning till blinding flash
c logicals were explained earlier
c read the database--resume restores variables at 8305 and proceeds
c
write (*,1000)
1000 format(//////////////,
. ' Adventure! (The original Colossal Cave!)',
. ///,' (Implemented for MS DOS in PDS FORTRAN v5.10',
. /,' by Paul Muñoz-Colman, FunStuff Software.',
. /,' Version 27 March 1993.)',
. ////////,' Initializing, Please Wait ...')
c
open (1, file='ad.dat', form='unformatted')
c
c read the data base in array format
c
read (1) abbnum,axe,back,batter,bear,bird,bonus,bottle,
. cage,cave,chain,chasm,chest,chloc,chloc2,clam,
. clock1,clock2,closed,closng,coins,daltlc,detail,dflag,
. dkill,dloc,door,dprssn,dragon,dseen,dwarf,eggs,
. emrald,entrnc,find,fissur,foobar,food,gaveup,grate
c
read (1) invent,iwest,keys,knfloc,knife,lamp,lmwarn,
. lock,look,magzin,maxdie,maxtrs,messag,mirror,nugget,
. null,numdie,oil,oyster,panic,pearl,pillow,plant,
. plant2,pyram,rod,rod2,rug,saved,say,scorng,
. snake,spices,steps,tablet,tally,tally2,throw,tridnt,
. troll,troll2,turns,vase,vend,water,tabsiz,blklin,oldloc,fixed
c
read (1) linuse,trvs,tabndx,obj,verb,clsses,hntmax,loc,newloc,
. k,j,stext,ltext,ptext,rtext,ctext,cval,key,
. travel,ktab,plac,fixd,actspk,cond,hints,place,prop,link,
. abb,atloc,holdng,hinted,hintlc,kk,i,itk,atab,lines
c
close (1)
write (*,10001)
10001 format('+ ')
c start-up, dwarf stuff
c
1 i=ran(1)
hinted(3)=yes(65,1,0)
newloc=1
limit=330
if(hinted(3).eq.1)limit=1000
c can't leave cave once it's closing (except by main office).
2 if(newloc.ge.9.or.newloc.eq.0.or.closng.eq.0) go to 71
call rspeak(130)
newloc=loc
if(panic.eq.0)clock2=15
panic=1
c see if a dwarf has seen him and has come from where he wants to go. if so,
c the dwarf's blocking his way. if coming from place forbidden to pirate
c (dwarves rooted in place) let him get out (and attacked).
71 if(newloc.eq.loc.or.forced(loc).eq.1.or.bitset(loc,3).eq.1)goto74
do 73 i=1,5
if(odloc(i).ne.newloc.or.dseen(i).eq.0)goto 73
newloc=loc
call rspeak(2)
goto 74
73 continue
74 loc=newloc
c dwarf stuff. see earlier comments for description of variables. remember
c sixth dwarf is pirate and is thus very different except for motion rules.
c first off, don't let the dwarves follow him into a pit or a wall. activate
c the whole mess the first time he gets as far as the hall of mists (loc 15).
c if newloc is forbidden to pirate (in particular, if it's beyond the troll
c bridge), bypass dwarf stuff. that way pirate can't steal return toll, and
c dwarves can't meet the bear. also means dwarves won't follow him into dead
c end in maze, but c'est la vie. they'll wait for him outside the dead end.
nl=newloc
if(loc.eq.0.or.forced(loc).eq.1.or.bitset(nl,3).eq.1)goto2000
if(dflag.ne.0)goto 6000
if(loc.ge.15)dflag=1
goto 2000
c when we encounter the first dwarf, we kill 0, 1, or 2 of the 5 dwarves. if
c any of the survivors is at loc, replace him with the alternate.
6000 if(dflag.ne.1)goto 6010
if(loc.lt.15.or.pct(95).eq.1)goto 2000
dflag=2
do 6001 i=1,2
j=1+ran(5)
6001 if(pct(50).eq.1) dloc(j)=0
do 6002 i=1,5
if(dloc(i).eq.loc)dloc(i)=daltlc
6002 odloc(i)=dloc(i)
call rspeak(3)
call drop(axe,loc)
goto 2000
c things are in full swing. move each dwarf at random, except if he's seen us
c he sticks with us. dwarves never go to locs <15. if wandering at random,
c they don't back up unless there's no alternative. if they don't have to
c move, they attack. and, of course, dead dwarves don't do much of anything.
6010 dtotal=0
attack=0
stick=0
do 6030 i=1,6
if(dloc(i).eq.0)goto 6030
j=1
kk=dloc(i)
kk=key(kk)
if(kk.eq.0)goto 6016
6012 newloc=mod(iabs(travel(kk))/1000,1000)
nl=newloc
trv=iabs(travel(kk))/1000000
itk2=itk(j-1)
if(nl.gt.300.or.nl.lt.15.or.nl.eq.odloc(i)
. .or.(j.gt.1.and.nl.eq.itk2) .or.j.ge.20
. .or.nl.eq.dloc(i).or.forced(nl).eq.1
. .or.(i.eq.6.and.bitset(nl,3).eq.1)
. .or.trv.eq.100) go to 6014
itk(j)=newloc
j=j+1
6014 kk=kk+1
if(travel(kk-1).ge.0)goto 6012
6016 itk(j)=odloc(i)
if(j.ge.2)j=j-1
j=1+ran(j)
odloc(i)=dloc(i)
dloc(i)=itk(j)
zzz=0
if (dseen(i).eq.1.and.loc.ge.15) zzz=1
dseen(i)=0
if (zzz.eq.1.or.(dloc(i).eq.loc.or.odloc(i).eq.loc))dseen(i)=1
if(dseen(i).eq.0) go to 6030
dloc(i)=loc
if(i.ne.6)goto 6027
c the pirate's spotted him. he leaves him alone once we've found chest.
c k counts if a treasure is here. if not, and tally=tally2 plus one for
c an unseen chest, let the pirate be spotted.
if(loc.eq.chloc.or.prop(chest).ge.0)goto 6030
k=0
do 6020 j=50,maxtrs
c pirate won't take pyramid from plover room or dark room (too easy!).
if(j.eq.pyram.and.(loc.eq.plac(pyram)
. .or.loc.eq.plac(emrald)))goto 6020
idondx=j
if(toting(idondx).eq.1)goto 6022
6020 if(here(idondx).eq.1)k=1
if(tally.eq.tally2+1.and.k.eq.0.and.place(chest).eq.0
. .and.here(lamp).eq.1.and.prop(lamp).eq.1)goto 6025
if(odloc(6).ne.dloc(6).and.pct(20).eq.1)call rspeak(127)
goto 6030
6022 call rspeak(128)
c don't steal chest back from troll!
if(place(messag).eq.0)call move(chest,chloc)
call move(messag,chloc2)
do 6023 j=50,maxtrs
if(j.eq.pyram.and.(loc.eq.plac(pyram)
. .or.loc.eq.plac(emrald)))goto 6023
idondx=j
if(at(idondx).eq.1.and.fixed(idondx).eq.0)
. call carry(idondx,loc)
if(toting(idondx).eq.1)call drop(idondx,chloc)
6023 continue
6024 dloc(6)=chloc
odloc(6)=chloc
dseen(6)=0
goto 6030
6025 call rspeak(186)
call move(chest,chloc)
call move(messag,chloc2)
goto 6024
c this threatening little dwarf is in the room with him!
6027 dtotal=dtotal+1
if(odloc(i).ne.dloc(i))goto 6030
attack=attack+1
if(knfloc.ge.0)knfloc=loc
if(ran(1000).lt.95*(dflag-2))stick=stick+1
6030 continue
c now we know what's happening. let's tell the poor sucker about it.
if(dtotal.eq.0)goto 2000
if(dtotal.eq.1)goto 75
write (*,67) dtotal
67 format(/' There are ',i1,' THREATENING LITTLE DWARVES in the'
.,' room with you.')
goto 77
75 call rspeak(4)
77 if(attack.eq.0)goto 2000
if(dflag.eq.2)dflag=3
if(attack.eq.1)goto 79
write (*,78) attack
78 format(/' ',i1,' of them THROW KNIVES at you!')
k=6
82 if(stick.gt.1)goto 83
call rspeak(k+stick)
if(stick.eq.0)goto 2000
goto 84
83 write (*,68) stick
68 format(/' ',i1,' of them get you!')
84 oldlc2=loc
goto 99
79 call rspeak(5)
k=52
goto 82
c describe the current location and (maybe) get next command.
c print text for current loc.
2000 if(loc.eq.0)goto 99
kk=stext(loc)
if(mod(abb(loc),abbnum).eq.0.or.kk.eq.0)kk=ltext(loc)
if(forced(loc).eq.1.or.dark(0).eq.0)goto 2001
if(wzdark.eq.1.and.pct(35).eq.1)goto 90
kk=rtext(16)
2001 if(toting(bear).eq.1)call rspeak(141)
kk2=kk
call speak(kk2)
k=1
if(forced(loc).eq.1)goto 8
if(loc.eq.33.and.pct(25).eq.1.and.closng.eq.0)call rspeak(8)
c print out descriptions of objects at this location. if not closing and
c property value is negative, tally off another treasure. rug is special
c case; once seen, its prop is 1 (dragon on it) till dragon is killed.
c similarly for chain; prop is initially 1 (locked to bear). these hacks
c are because prop=0 is needed to get full score.
if(dark(0).eq.1)goto 2012
abb(loc)=abb(loc)+1
i=atloc(loc)
blklin=1
2004 if(i.eq.0)goto 2012
obj=i
if(obj.gt.100)obj=obj-100
if(obj.eq.steps.and.toting(nugget).eq.1)goto 2008
if(prop(obj).ge.0)goto 2006
if(closed.eq.1)goto 2008
prop(obj)=0
if(obj.eq.rug.or.obj.eq.chain)prop(obj)=1
tally=tally-1
c if remaining treasures too elusive, zap his lamp.
if(tally.eq.tally2.and.tally.ne.0)limit=min0(35,limit)
2006 kk=prop(obj)
if(obj.eq.steps.and.loc.eq.fixed(steps))kk=1
kk2=kk
call pspeak(obj,kk2)
if (blklin.eq.1) blklin=0
2008 i=link(i)
goto 2004
2009 k=54
2010 spk=k
2011 call rspeak(spk)
2012 verb=0
obj=0
blklin=1
c check if this loc is eligible for any hints. if been here long enough,
c branch to help section (on later page). hints all come back here eventually
c to finish the loop. ignore "hints" < 4 (special stuff, see database notes).
2600 do 2602 hint=4,hntmax
if(hinted(hint).eq.1)goto 2602
idondx=hint
if(bitset(loc,idondx).eq.0)hintlc(hint)=-1
hintlc(hint)=hintlc(hint)+1
if(hintlc(hint).ge.hints(hint,1))goto 40000
2602 continue
c kick the random number generator just to add variety to the chase. also,
c if closing time, check for any objects being toted with prop < 0 and set
c the prop to -1-prop. this way objects won't be described until they've
c been picked up and put down seperate from their seperate piles. don't
c tick clock1 unless well into cave (and not at y2).
c
26021 continue
if(closed.eq.0)goto 2605
if(prop(oyster).lt.0.and.toting(oyster).eq.1)
. call pspeak(oyster,1)
do 2604 i=1,100
idondx=i
2604 if(toting(idondx).eq.1.and.prop(idondx).lt.0)
. prop(idondx)=-1-prop(idondx)
2605 wzdark=dark(0)
if(knfloc.gt.0.and.knfloc.ne.loc)knfloc=0
i=ran(1)
call getin(wd1,wd1x,wd2,wd2x)
c every input, check "foobar" flag. if zero, nothing's going on. if pos,
c make neg. if neg, he skipped a word, so make it zero.
2608 foobar=min0(0,-foobar)
if (turns.eq.0.and.wd1.eq.'resu')go to 8305
turns=turns+1
if(verb.eq.say.and.wd2.ne.iz)verb=0
if(verb.eq.say)goto 4090
if(tally.eq.0.and.loc.ge.15.and.loc.ne.33)clock1=clock1-1
if(clock1.eq.0)goto 10000
if(clock1.lt.0)clock2=clock2-1
if(clock2.eq.0)goto 11000
if(prop(lamp).eq.1)limit=limit-1
if(limit.le.30.and.here(batter).eq.1.and.prop(batter).eq.0
. .and.here(lamp).eq.1)goto 12000
if(limit.eq.0)goto 12400
if(limit.lt.0.and.loc.le.8)goto 12600
if(limit.le.30)goto 12200
19999 k=43
if(liqloc(loc).eq.water)k=70
if(wd1.eq.'ente'.and.(wd2.eq.'stre'.or.wd2.eq.'wate'))
. goto 2010
if(wd1.eq.'ente'.and.wd2.ne.iz)goto 2800
if((wd1.ne.'wate'.and.wd1.ne.'oil ')
. .or.(wd2.ne.'plan'.and.wd2.ne.'door'))goto 2610
if(at(vocab(wd2,1)).eq.1)wd2='pour'
2610 if(wd1.ne.'west')goto 2630
iwest=iwest+1
if(iwest.eq.10)call rspeak(17)
2630 i=vocab(wd1,-1)
if(i.eq.-1)goto 3000
k=mod(i,1000)
kq=i/1000+1
if(kq.gt.4) call bug(22)
goto (8,5000,4000,2010),kq
c get second word for analysis.
2800 wd1=wd2
wd1x=wd2x
wd2=iz
goto 2610
c gee, i don't understand.
3000 spk=60
if(pct(20).eq.1)spk=61
if(pct(20).eq.1)spk=13
call rspeak(spk)
goto 2600
c analyze a verb. remember what it was, go back for object if second word
c unless verb is "say", which snarfs arbitrary second word.
4000 verb=k
spk=actspk(verb)
if(wd2.ne.iz.and.verb.ne.say)goto 2800
if(verb.eq.say)obj=wd2
if(verb.gt.31)call bug(23)
if(obj.ne.0)goto 4090
c analyze an intransitive verb (ie, no object given yet).
4080 goto(8010,8000,8000,8040,2009,8040,9070,9080,8000,8000,
. 2011,9120,9130,8140,9150,8000,8000,8180,8000,8200,
. 8000,9220,9230,8240,8250,8260,8270,8000,8000,8300,
. 8310),verb
c take drop say open noth lock on off wave calm
c walk kill pour eat drnk rub toss quit find invn
c feed fill blst scor foo brf read brek wake susp
c hour
c analyze a transitive verb.
4090 goto(9010,9020,9030,9040,2009,9040,9070,9080,9090,2011,
. 2011,9120,9130,9140,9150,9160,9170,2011,9190,9190,
. 9210,9220,9230,2011,2011,2011,9270,9280,9290,2011,
. 2011),verb
c take drop say open noth lock on off wave calm
c walk kill pour eat drnk rub toss quit find invn
c feed fill blst scor foo brf read brek wake susp
c hour
c analyze an object word. see if the thing is here, whether we've got a verb
c yet, and so on. object must be here unless verb is "find" or "invent(ory)"
c (and no new verb yet to be analyzed). water and oil are also funny, since
c they are never actually dropped at any location, but might be here inside
c the bottle or as a feature of the location.
5000 obj=k
if(fixed(k).ne.loc.and.here(k).eq.0)goto 5100
5010 if(wd2.ne.iz)goto 2800
if(verb.ne.0)goto 4090
call a5toa1(wd1,wd1x,'? ',' ',tk,k)
write (*,5015) (tk(i),i=1,k)
5015 format(/' What do you want to do with the ',20a1)
goto 2600
5100 if(k.ne.grate)goto 5110
if(loc.eq.1.or.loc.eq.4.or.loc.eq.7)k=dprssn
if(loc.gt.9.and.loc.lt.15)k=entrnc
if(k.ne.grate)goto 8
5110 if(k.ne.dwarf)goto 5120
do 5112 i=1,5
if(dloc(i).eq.loc.and.dflag.ge.2)goto 5010
5112 continue
5120 if((liq(0).eq.k.and.here(bottle).eq.1).or.k.eq.liqloc(loc))
. go to 5010
if(obj.ne.plant.or.at(plant2).eq.0.or.prop(plant2).eq.0)goto 5130
obj=plant2
goto 5010
5130 if(obj.ne.knife.or.knfloc.ne.loc)goto 5140
knfloc=-1
spk=116
goto 2011
5140 if(obj.ne.rod.or.here(rod2).eq.0)go to 5190
obj=rod2
goto 5010
5190 if((verb.eq.find.or.verb.eq.invent).and.wd2.eq.iz)goto 5010
call a5toa1(wd1,wd1x,' her','e. ',tk,k)
write (*,5199) (tk(i),i=1,k)
5199 format(/' I see no ',20a1)
goto 2012
c figure out the new location
c
c given the current location in "loc", and a motion verb number in "k", put
c the new location in "newloc". the current loc is saved in "oldloc" in case
c he wants to retreat. the current oldloc is saved in oldlc2, in case he
c dies. (if he does, newloc will be limbo, and oldloc will be what killed
c him, so we need oldlc2, which is the last place he was safe.)
8 kk=key(loc)
newloc=loc
if(kk.eq.0)call bug(26)
if(k.eq.null)goto 2
if(k.eq.back)goto 20
if(k.eq.look)goto 30
if(k.eq.cave)goto 40
oldlc2=oldloc
oldloc=loc
9 ll=iabs(travel(kk))
if(mod(ll,1000).eq.1.or.mod(ll,1000).eq.k)goto 10
if(travel(kk).lt.0)goto 50
kk=kk+1
goto 9
10 ll=ll/1000
11 newloc=ll/1000
k=mod(newloc,100)
if(newloc.le.300)goto 13
nl=newloc
if(prop(k).ne.((nl/100)-3)) go to 16
12 if(travel(kk).lt.0)call bug(25)
kk=kk+1
newloc=iabs(travel(kk))/1000
if(newloc.eq.ll)goto 12
ll=newloc
goto 11
13 if(newloc.le.100)goto 14
nl=newloc
if(toting(k).eq.1.or.(nl.gt.200.and.at(k).eq.1))goto 16
goto 12
14 nl=newloc
if(nl.ne.0.and.pct(nl).eq.0) go to 12
16 newloc=mod(ll,1000)
if(newloc.le.300)goto 2
if(newloc.le.500)goto 30000
nl=newloc
call rspeak(nl-500)
newloc=loc
goto 2
c special motions come here. labelling convention: statement numbers nnnxxc (
30000 newloc=newloc-300
if(newloc.gt.3)call bug(20)
goto (30100,30200,30300),newloc
c travel 301. plover-alcove passage. can carry only emerald. note: travel
c table must include "useless" entries going through passage, which can never
c be used for actual motion, but can be spotted by "go back".
30100 newloc=99+100-loc
if(holdng.eq.0.or.(holdng.eq.1.and.toting(emrald).eq.1))goto 2
newloc=loc
call rspeak(117)
goto 2
c travel302. plover transport. drop the emerald (only use special travel if
c toting it), so he's forced to use the plover-passage to get it out. having
c dropped it, go back and pretend he wasn't carrying it after all.
30200 call drop(emrald,loc)
goto 12
c travel 303. troll bridge. must be done only as special motion so that
c dwarves won't wander across and encounter the bear. (they won't follow the
c player there because that region is forbidden to the pirate.) if
c prop(troll)=1, he's crossed since paying, so step out and block him.
c (standard travel entries check for prop(troll)=0.) special stuff for bear.
30300 if(prop(troll).ne.1)goto 30310
call pspeak(troll,1)
prop(troll)=0
call move(troll2,0)
call move(troll2+100,0)
call move(troll,plac(troll))
call move(troll+100,fixd(troll))
call juggle(chasm)
newloc=loc
goto 2
30310 newloc=plac(troll)+fixd(troll)-loc
if(prop(troll).eq.0)prop(troll)=1
if(toting(bear).eq.0)goto 2
call rspeak(162)
prop(chasm)=1
prop(troll)=2
nl=newloc
call drop(bear,nl)
fixed(bear)=-1
prop(bear)=3
if(prop(spices).lt.0)tally2=tally2+1
oldlc2=newloc
goto 99
c end of specials.
c handle "go back". look for verb which goes from loc to oldloc, or to oldlc2
c if oldloc has forced-motion. k2 saves entry -> forced loc -> previous loc.
20 k=oldloc
if(forced(k).eq.1)k=oldlc2
oldlc2=oldloc
oldloc=loc
k2=0
if(k.ne.loc)goto 21
call rspeak(91)
goto 2
21 ll=mod((iabs(travel(kk))/1000),1000)
if(ll.eq.k)goto 25
if(ll.gt.300)goto 22
j=key(ll)
ls=ll
trv=mod((iabs(travel(j))/1000),1000)
if(forced(ls).eq.1.and.trv.eq.k)
. k2=kk
22 if(travel(kk).lt.0)goto 23
kk=kk+1
goto 21
23 kk=k2
if(kk.ne.0)goto 25
call rspeak(140)
goto 2
25 k=mod(iabs(travel(kk)),1000)
kk=key(loc)
goto 9
c look. can't give more detail. pretend it wasn't dark (though it may "now"
c be dark) so he won't fall into a pit while staring into the gloom.
30 if(detail.lt.3)call rspeak(15)
detail=detail+1
wzdark=0
abb(loc)=0
goto 2
c cave. different messages depending on whether above ground.
40 if(loc.lt.8)call rspeak(57)
if(loc.ge.8)call rspeak(58)
goto 2
c non-applicable motion. various messages depending on word given.
50 spk=12
if(k.ge.43.and.k.le.50)spk=9
if(k.eq.29.or.k.eq.30)spk=9
if(k.eq.7.or.k.eq.36.or.k.eq.37)spk=10
if(k.eq.11.or.k.eq.19)spk=11
if(verb.eq.find.or.verb.eq.invent)spk=59
if(k.eq.62.or.k.eq.65)spk=42
if(k.eq.17)spk=80
call rspeak(spk)
goto 2
c "you're dead, jim."
c
c if the current loc is zero, it means the clown got himself killed. we'll
c allow this maxdie times. maxdie is automatically set based on the number of
c snide messages available. each death results in a message (81, 83, etc.)
c which offers reincarnation; if accepted, this results in message 82, 84,
c etc. the last time, if he wants another chance, he gets a snide remark as
c we exit. when reincarnated, all objects being carried get dropped at oldlc2
c (presumably the last place prior to being killed) without change of props.
c the loop runs backwards to assure that the bird is dropped before the cage.
c (this kluge could be changed once we're sure all references to bird and cage
c are done by keywords.) the lamp is a special case (it wouldn't do to leave
c it in the cave). it is turned off and left outside the building (only if he
c was carrying it, of course). he himself is left inside the building (and
c heaven help him if he tries to xyzzy back into the cave without the lamp).
c oldloc is zapped so he can't just "retreat".
c the easiest way to get killed is to fall into a pit in pitch darkness.
90 call rspeak(23)
oldlc2=loc
c okay, he's dead. let's get on with it.
99 if(closng.eq.1)goto 95
yea=yes(81+numdie*2,82+numdie*2,54)
numdie=numdie+1
if(numdie.eq.maxdie.or.yea.eq.0)goto 20000
place(water)=0
place(oil)=0
if(toting(lamp).eq.1)prop(lamp)=0
do 98 j=1,100
i=101-j
if(toting(i).eq.0)goto 98
k=oldlc2
if(i.eq.lamp)k=1
call drop(i,k)
98 continue
loc=3
oldloc=loc
goto 2000
c he died during closing time. no resurrection. tally up a death and exit.
95 call rspeak(131)
numdie=numdie+1
goto 20000
c routines for performing the various action verbs
c statement numbers in this section are 8000 for intransitive verbs, 9000 for
c transitive, plus ten times the verb number. many intransitive verbs use the
c transitive code, and some verbs use code for other verbs, as noted below.
c random intransitive verbs come here. clear obj just in case (see "attack").
8000 call a5toa1(wd1,wd1x,' wha','t? ',tk,k)
write (*,8002) (tk(i),i=1,k)
8002 format(/' ',20a1)
obj=0
goto 2600
c carry, no object given yet. ok if only one object present.
8010 if(atloc(loc).eq.0.or.link(atloc(loc)).ne.0)goto 8000
do 8012 i=1,5
if(dloc(i).eq.loc.and.dflag.ge.2)goto 8000
8012 continue
obj=atloc(loc)
c carry an object. special cases for bird and cage (if bird in cage, can't
c take one without the other. liquids also special, since they depend on
c status of bottle. also various side effects, etc.
9010 if(toting(obj).eq.1)goto 2011
spk=25
if(obj.eq.plant.and.prop(plant).le.0)spk=115
if(obj.eq.bear.and.prop(bear).eq.1)spk=169
if(obj.eq.chain.and.prop(bear).ne.0)spk=170
if(fixed(obj).ne.0)goto 2011
if(obj.ne.water.and.obj.ne.oil)goto 9017
if(here(bottle).eq.1.and.liq(0).eq.obj)goto 9018
obj=bottle
if(toting(bottle).eq.1.and.prop(bottle).eq.1)goto 9220
if(prop(bottle).ne.1)spk=105
if(toting(bottle).eq.0)spk=104
goto 2011
9018 obj=bottle
9017 if(holdng.lt.7)goto 9016
call rspeak(92)
goto 2012
9016 if(obj.ne.bird)goto 9014
if(prop(bird).ne.0)goto 9014
if(toting(rod).eq.0)goto 9013
call rspeak(26)
goto 2012
9013 if(toting(cage).eq.1)goto 9015
call rspeak(27)
goto 2012
9015 prop(bird)=1
9014 if((obj.eq.bird.or.obj.eq.cage).and.prop(bird).ne.0)
. call carry(bird+cage-obj,loc)
call carry(obj,loc)
k=liq(0)
if(obj.eq.bottle.and.k.ne.0)place(k)=-1
goto 2009
c discard object. "throw" also comes here for most objects. special cases for
c bird (might attack snake or dragon) and cage (might contain bird) and vase.
c drop coins at vending machine for extra batteries.
9020 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
if(toting(obj).eq.0)goto 2011
if(obj.ne.bird.or.here(snake).eq.0)goto 9024
call rspeak(30)
if(closed.eq.1)goto 19000
call dstroy(snake)
c set prop for use by travel options
prop(snake)=1
9021 k=liq(0)
if(k.eq.obj)obj=bottle
if(obj.eq.bottle.and.k.ne.0)place(k)=0
if(obj.eq.cage.and.prop(bird).ne.0)call drop(bird,loc)
if(obj.eq.bird)prop(bird)=0
call drop(obj,loc)
goto 2012
9024 if(obj.ne.coins.or.here(vend).eq.0)goto 9025
call dstroy(coins)
call drop(batter,loc)
call pspeak(batter,0)
goto 2012
9025 if(obj.ne.bird.or.at(dragon).eq.0.or.prop(dragon).ne.0)goto 9026
call rspeak(154)
call dstroy(bird)
prop(bird)=0
if(place(snake).eq.plac(snake))tally2=tally2+1
goto 2012
9026 if(obj.ne.bear.or.at(troll).eq.0)goto 9027
call rspeak(163)
call move(troll,0)
call move(troll+100,0)
call move(troll2,plac(troll))
call move(troll2+100,fixd(troll))
call juggle(chasm)
prop(troll)=2
goto 9021
9027 if(obj.eq.vase.and.loc.ne.plac(pillow))goto 9028
call rspeak(54)
goto 9021
9028 prop(vase)=2
if(at(pillow).eq.1)prop(vase)=0
call pspeak(vase,prop(vase)+1)
if(prop(vase).ne.0)fixed(vase)=-1
goto 9021
c say. echo wd2 (or wd1 if no wd2 (say what?, etc.).) magic words override.
9030 call a5toa1(wd2,wd2x,'". ',' ',tk,k)
if(wd2.eq.iz)call a5toa1(wd1,wd1x,'". ',' ',tk,k)
if(wd2.ne.iz)wd1=wd2
i=vocab(wd1,-1)
if(i.eq.62.or.i.eq.65.or.i.eq.71.or.i.eq.2025)goto 9035
write (*,9032) (tk(i),i=1,k)
9032 format(/' Okay, "',20a1)
goto 2012
9035 wd2=iz
obj=0
goto 2630
c lock, unlock, no object given. assume various things if present.
8040 spk=28
if(here(clam).eq.1)obj=clam
if(here(oyster).eq.1)obj=oyster
if(at(door).eq.1)obj=door
if(at(grate).eq.1)obj=grate
if(obj.ne.0.and.here(chain).eq.1)goto 8000
if(here(chain).eq.1)obj=chain
if(obj.eq.0)goto 2011
c lock, unlock object. special stuff for opening clam/oyster and for chain.
9040 if(obj.eq.clam.or.obj.eq.oyster)goto 9046
if(obj.eq.door)spk=111
if(obj.eq.door.and.prop(door).eq.1)spk=54
if(obj.eq.cage)spk=32
if(obj.eq.keys)spk=55
if(obj.eq.grate.or.obj.eq.chain)spk=31
if(spk.ne.31.or.here(keys).eq.0)goto 2011
if(obj.eq.chain)goto 9048
if(closng.eq.0)goto 9043
k=130
if(panic.eq.0)clock2=15
panic=1
goto 2010
9043 k=34+prop(grate)
prop(grate)=1
if(verb.eq.lock)prop(grate)=0
k=k+2*prop(grate)
goto 2010
c clam/oyster.
9046 k=0
if(obj.eq.oyster)k=1
spk=124+k
if(toting(obj).eq.1)spk=120+k
if(toting(tridnt).eq.0)spk=122+k
if(verb.eq.lock)spk=61
if(spk.ne.124)goto 2011
call dstroy(clam)
call drop(oyster,loc)
call drop(pearl,105)
goto 2011
c chain.
9048 if(verb.eq.lock)goto 9049
spk=171
if(prop(bear).eq.0)spk=41
if(prop(chain).eq.0)spk=37
if(spk.ne.171)goto 2011
prop(chain)=0
fixed(chain)=0
if(prop(bear).ne.3)prop(bear)=2
fixed(bear)=2-prop(bear)
goto 2011
9049 spk=172
if(prop(chain).ne.0)spk=34
if(loc.ne.plac(chain))spk=173
if(spk.ne.172)goto 2011
prop(chain)=2
if(toting(chain).eq.1)call drop(chain,loc)
fixed(chain)=-1
goto 2011
c light lamp
9070 if(here(lamp).eq.0)goto 2011
spk=184
if(limit.lt.0)goto 2011
prop(lamp)=1
call rspeak(39)
if(wzdark.eq.1)goto 2000
goto 2012
c lamp off
9080 if(here(lamp).eq.0)goto 2011
prop(lamp)=0
call rspeak(40)
if(dark(0).eq.1)call rspeak(16)
goto 2012
c wave. no effect unless waving rod at fissure.
9090 if((toting(obj)).eq.0.and.(obj.ne.rod.or.toting(rod2).eq.0))
. spk=29
if(obj.ne.rod.or.at(fissur).eq.0.or.toting(obj).eq.0
. .or.closng.eq.1)go to 2011
prop(fissur)=1-prop(fissur)
call pspeak(fissur,2-prop(fissur))
goto 2012
c attack. assume target if unambiguous. "throw" also links here. attackable
c objects fall into two categories: enemies (snake, dwarf, etc.) and others
c (bird, clam). ambiguous if two enemies, or if no enemies but two others.
9120 do 9121 i=1,5
if(dloc(i).eq.loc.and.dflag.ge.2)goto 9122
9121 continue
i=0
9122 if(obj.ne.0)goto 9124
if(i.ne.0)obj=dwarf
if(here(snake).eq.1)obj=obj*100+snake
if(at(dragon).eq.1.and.prop(dragon).eq.0)obj=obj*100+dragon
if(at(troll).eq.1)obj=obj*100+troll
if(here(bear).eq.1.and.prop(bear).eq.0)obj=obj*100+bear
if(obj.gt.100)goto 8000
if(obj.ne.0)goto 9124
c can't attack bird by throwing axe.
if(here(bird).eq.1.and.verb.ne.throw)obj=bird
c clam and oyster both treated as clam for intransitive case; no harm done.
if(here(clam).eq.1.or.here(oyster).eq.1)obj=100*obj+clam
if(obj.gt.100)goto 8000
9124 if(obj.ne.bird)goto 9125
spk=137
if(closed.eq.1)goto 2011
call dstroy(bird)
prop(bird)=0
if(place(snake).eq.plac(snake))tally2=tally2+1
spk=45
9125 if(obj.eq.0)spk=44
if(obj.eq.clam.or.obj.eq.oyster)spk=150
if(obj.eq.snake)spk=46
if(obj.eq.dwarf)spk=49
if(obj.eq.dwarf.and.closed.eq.1)goto 19000
if(obj.eq.dragon)spk=167
if(obj.eq.troll)spk=157
if(obj.eq.bear)spk=165+(prop(bear)+1)/2
if(obj.ne.dragon.or.prop(dragon).ne.0)goto 2011
c fun stuff for dragon. if he insists on attacking it, win! set prop to dead,
c move dragon to central loc (still fixed), move rug there (not fixed), and
c move him there, too. then do a null motion to get new description.
call rspeak(49)
verb=0
obj=0
call getin(wd1,wd1x,wd2,wd2x)
if(wd1.ne.'y '.and.wd1.ne.'yes ')goto 2608
call pspeak(dragon,1)
prop(dragon)=2
prop(rug)=0
k=(plac(dragon)+fixd(dragon))/2
call move(dragon+100,-1)
call move(rug+100,0)
call move(dragon,k)
call move(rug,k)
do 9126 obj=1,100
idondx=obj
if(place(idondx).eq.plac(dragon).or.
. place(idondx).eq.fixd(dragon))
. call move(idondx,k)
9126 continue
loc=k
k=null
goto 8
c pour. if no object, or object is bottle, assume contents of bottle.
c special tests for pouring water or oil on plant or rusty door.
9130 if(obj.eq.bottle.or.obj.eq.0)obj=liq(0)
if(obj.eq.0)goto 8000
if(toting(obj).eq.0)goto 2011
spk=78
if(obj.ne.oil.and.obj.ne.water)goto 2011
prop(bottle)=1
place(obj)=0
spk=77
if(at(plant).eq.0.and.at(door).eq.0) go to 2011
if(at(door).eq.1)goto 9132
spk=112
if(obj.ne.water)goto 2011
call pspeak(plant,prop(plant)+1)
prop(plant)=mod(prop(plant)+2,6)
prop(plant2)=prop(plant)/2
k=null
goto 8
9132 prop(door)=0
if(obj.eq.oil)prop(door)=1
spk=113+prop(door)
goto 2011
c eat. intransitive: assume food if present, else ask what. transitive: food
c ok, some things lose appetite, rest are ridiculous.
8140 if(here(food).eq.0)goto 8000
8142 call dstroy(food)
spk=72
goto 2011
9140 if(obj.eq.food)goto 8142
if(obj.eq.bird.or.obj.eq.snake.or.obj.eq.clam.or.obj.eq.oyster
. .or.obj.eq.dwarf.or.obj.eq.dragon.or.obj.eq.troll
. .or.obj.eq.bear)spk=71
goto 2011
c drink. if no object, assume water and look for it here. if water is in
c the bottle, drink that, else must be at a water loc, so drink stream.
9150 if(obj.eq.0.and.liqloc(loc).ne.water.and.(liq(0).ne.water
. .or.here(bottle).eq.0))goto 8000
if(obj.ne.0.and.obj.ne.water)spk=110
if(spk.eq.110.or.liq(0).ne.water.or.here(bottle).eq.0)goto 2011
prop(bottle)=1
place(water)=0
spk=74
goto 2011
c rub. yields various snide remarks.
9160 if(obj.ne.lamp)spk=76
goto 2011
c throw. same as discard unless axe. then same as attack except ignore bird,
c and if dwarf is present then one might be killed. (only way to do so)
c axe also special for dragon, bear, and troll. treasures special for troll.
9170 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
if(toting(obj).eq.0)goto 2011
if(obj.ge.50.and.obj.le.maxtrs.and.at(troll).eq.1)goto 9178
if(obj.eq.food.and.here(bear).eq.1)goto 9177
if(obj.ne.axe)goto 9020
do 9171 i=1,5
c needn't check dflag if axe is here.
if(dloc(i).eq.loc)goto 9172
9171 continue
spk=152
if(at(dragon).eq.1.and.prop(dragon).eq.0)goto 9175
spk=158
if(at(troll).eq.1)goto 9175
if(here(bear).eq.1.and.prop(bear).eq.0)goto 9176
obj=0
goto 9120
9172 spk=48
if(ran(3).eq.0) go to 9175
dseen(i)=0
dloc(i)=0
spk=47
dkill=dkill+1
if(dkill.eq.1)spk=149
9175 call rspeak(spk)
call drop(axe,loc)
k=null
goto 8
c this'll teach him to throw the axe at the bear!
9176 spk=164
call drop(axe,loc)
fixed(axe)=-1
prop(axe)=1
call juggle(bear)
goto 2011
c but throwing food is another story.
9177 obj=bear
goto 9210
9178 spk=159
c snarf a treasure for the troll.
call drop(obj,0)
call move(troll,0)
call move(troll+100,0)
call drop(troll2,plac(troll))
call drop(troll2+100,fixd(troll))
call juggle(chasm)
goto 2011
c quit. intransitive only. verify intent and exit if that's what he wants.
8180 gaveup=yes(22,54,54)
8185 if(gaveup.eq.1)goto 20000
goto 2012
c find. might be carrying it, or it might be here. else give caveat.
9190 if(at(obj).eq.1.or.(liq(0).eq.obj.and.at(bottle).eq.1)
. .or.k.eq.liqloc(loc))spk=94
do 9192 i=1,5
9192 if(dloc(i).eq.loc.and.dflag.ge.2.and.obj.eq.dwarf)spk=94
if(closed.eq.1)spk=138
if(toting(obj).eq.1)spk=24
goto 2011
c inventory. if object, treat same as find. else report on current burden.
8200 spk=98
blklin=1
do 8201 i=1,100
idondx=i
if(idondx.eq.bear.or.toting(idondx).eq.0)goto 8201
if(spk.eq.98)call rspeak(99)
call pspeak(idondx,-1)
if (blklin.eq.1) blklin=0
spk=0
8201 continue
blklin=1
if(toting(bear).eq.1)spk=141
goto 2011
c feed. if bird, no seed. snake, dragon, troll: quip. if dwarf, make him
c mad. bear, special.
9210 if(obj.ne.bird)goto 9212
spk=100
goto 2011
9212 if(obj.ne.snake.and.obj.ne.dragon.and.obj.ne.troll)goto 9213
spk=102
if(obj.eq.dragon.and.prop(dragon).ne.0)spk=110
if(obj.eq.troll)spk=182
if(obj.ne.snake.or.closed.eq.1.or.here(bird).eq.0)goto 2011
spk=101
call dstroy(bird)
prop(bird)=0
tally2=tally2+1
goto 2011
9213 if(obj.ne.dwarf)goto 9214
if(here(food).eq.0)goto 2011
spk=103
dflag=dflag+1
goto 2011
9214 if(obj.ne.bear)goto 9215
if(prop(bear).eq.0)spk=102
if(prop(bear).eq.3)spk=110
if(here(food).eq.0)goto 2011
call dstroy(food)
prop(bear)=1
fixed(axe)=0
prop(axe)=0
spk=168
goto 2011
9215 spk=14
goto 2011
c fill. bottle must be empty, and some liquid available. (vase is nasty.)
9220 if(obj.eq.vase)goto 9222
if(obj.ne.0.and.obj.ne.bottle)goto 2011
if(obj.eq.0.and.here(bottle).eq.0)goto 8000
spk=107
if(liqloc(loc).eq.0)spk=106
if(liq(0).ne.0)spk=105
if(spk.ne.107)goto 2011
prop(bottle)=mod(cond(loc),4)/2*2
k=liq(0)
if(toting(bottle).eq.1)place(k)=-1
if(k.eq.oil)spk=108
goto 2011
9222 spk=29
if(liqloc(loc).eq.0)spk=144
if(liqloc(loc).eq.0.or.toting(vase).eq.0)goto 2011
call rspeak(145)
prop(vase)=2
fixed(vase)=-1
goto 9024
c blast. no effect unless you've got dynamite, which is a neat trick!
9230 if(prop(rod2).lt.0.or.closed.eq.0)goto 2011
bonus=133
if(loc.eq.115)bonus=134
if(here(rod2).eq.1)bonus=135
call rspeak(bonus)
goto 20000
c score. go to scoring section, which will return to 8241 if scorng is true.
8240 scorng=1
goto 20000
8241 scorng=0
write(*,8243) score, mxscor, turns
8243 format(/' If you were to quit now,',/,' You would score',i4
. ,' out of a possible',i4,', using ',i5,' turns.')
c gaveup=yes(143,54,54)
c goto 8185
go to 2012
c fee fie foe foo (and fum). advance to next state if given in proper order.
c look up wd1 in section 3 of vocab to determine which word we've got. last
c word zips the eggs back to the giant room (unless already there).
8250 k=vocab(wd1,3)
spk=42
if(foobar.eq.1-k)goto 8252
if(foobar.ne.0)spk=151
goto 2011
8252 foobar=k
if(k.ne.4)goto 2009
foobar=0
if(place(eggs).eq.plac(eggs)
. .or.(toting(eggs).eq.1.and.loc.eq.plac(eggs)))goto 2011
c bring back troll if we steal the eggs back from him before crossing.
if(place(eggs).eq.0.and.place(troll).eq.0.and.prop(troll).eq.0)
. prop(troll)=1
k=2
if(here(eggs).eq.1)k=1
if(loc.eq.plac(eggs))k=0
call move(eggs,plac(eggs))
call pspeak(eggs,k)
goto 2012
c brief. intransitive only. suppress long descriptions after first time.
8260 spk=156
abbnum=10000
detail=3
goto 2011
c read. magazines in dwarvish, message we've seen, and . . . oyster?
8270 if(here(magzin).eq.1)obj=magzin
if(here(tablet).eq.1)obj=obj*100+tablet
if(here(messag).eq.1)obj=obj*100+messag
if(closed.eq.1.and.toting(oyster).eq.1)obj=oyster
if(obj.gt.100.or.obj.eq.0.or.dark(0).eq.1)goto 8000
9270 if(dark(0).eq.1)goto 5190
if(obj.eq.magzin)spk=190
if(obj.eq.tablet)spk=196
if(obj.eq.messag)spk=191
if(obj.eq.oyster.and.hinted(2).eq.1.and.toting(oyster).eq.1)
. spk=194
if(obj.ne.oyster.or.hinted(2).eq.1.or.toting(oyster).eq.0
. .or.closed.eq.0)goto 2011
hinted(2)=yes(192,193,54)
goto 2012
c break. only works for mirror in repository and, of course, the vase.
9280 if(obj.eq.mirror)spk=148
if(obj.eq.vase.and.prop(vase).eq.0)goto 9282
if(obj.ne.mirror.or.closed.eq.0)goto 2011
call rspeak(197)
goto 19000
9282 spk=198
if(toting(vase).eq.1)call drop(vase,loc)
prop(vase)=2
fixed(vase)=-1
goto 2011
c wake. only use is to disturb the dwarves.
9290 if(obj.ne.dwarf.or.closed.eq.0)goto 2011
call rspeak(199)
goto 19000
c
c suspend. offer to exit and give specs on restart.
c upon restarting, "resume" on first turn only comes to 8305
c
8300 write (*,8302)
8302 format(/' I can suspend your Adventure for you so that you can',
. /,' restart later, but you will have to type "resume" on your',
. /,' FIRST TURN. The save process will write a 2772 byte file',
. /,' named ADVENTUR.SV in your current directory.')
c
if(yes(200,54,54).eq.0) go to 2012
c
c write data file with all the good stuff to resume from
c
open (2,file='adventur.sv',form='unformatted',status='unknown')
write (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
. hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
. limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
. foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
. ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
. closng
close (2)
c
write (*,83001)
83001 format(//,' Your Adventure has been saved. Type "resume"',/,
. ' on your FIRST TURN to restart where you left off.',//)
go to 25000
c
c resume saved game from data file adventur.sv. resume must be on
c first turn. comes here to read all variables as we wrote them
c and proceeds.
c
8305 open (2,file='adventur.sv',form='unformatted')
read (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
. hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
. limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
. foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
. ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
. closng
close (2)
yea=1
k=null
goto 8
c hours. report current non-prime-time hours.
8310 write (*,83101)
83101 format (/,' Colossal Cave is always open.')
goto 2012
c
c hints
c come here if he's been long enough at required loc(s) for some unused hint.
c hint number is in variable "hint". branch to quick test for additional
c conditions, then come back to do neat stuff. goto 40010 if conditions are
c met and we want to offer the hint. goto 40020 to clear hintlc back to zero,
c 40030 to take no action yet.
40000 if(hint.lt.4.or.hint.gt.9) call bug(27)
go to (40400,40500,40600,40700,40800,40900),(hint-3)
c cave bird snake maze dark witt
40010 hintlc(hint)=0
if(yes(hints(hint,3),0,54).eq.0)goto 26021
write (*,40012) hints (hint,2)
40012 format(/' I am prepared to give you a hint, but it will cost you',
. i2,' points.')
hinted(hint)=yes(175,hints(hint,4),54)
if(hinted(hint).eq.1.and.limit.gt.30)limit=limit+30*hints(hint,2)
40020 hintlc(hint)=0
40030 goto 26021
c now for the quick tests. see database description for one-line notes.
40400 if(prop(grate).eq.0.and.here(keys).eq.0)goto 40010
goto 40020
40500 if(here(bird).eq.1.and.toting(rod).eq.1.and.obj.eq.bird)goto40010
goto 40030
40600 if(here(snake).eq.1.and.here(bird).eq.0)goto 40010
goto 40020
40700 if(atloc(loc).eq.0.and.atloc(oldloc).eq.0
. .and.atloc(oldlc2).eq.0.and.holdng.gt.1)goto 40010
goto 40020
40800 if(prop(emrald).ne.-1.and.prop(pyram).eq.-1)goto 40010
goto 40020
40900 goto 40010
c cave closing and scoring
c these sections handle the closing of the cave. the cave closes "clock1"
c turns after the last treasure has been located (including the pirate's
c chest, which may of course never show up). note that the treasures need not
c have been taken yet, just located. hence clock1 must be large enough to get
c out of the cave (it only ticks while inside the cave). when it hits zero,
c we branch to 10000 to start closing the cave, and then sit back and wait for
c him to try to get out. if he doesn't within clock2 turns, we close the
c cave; if he does try, we assume he panics, and give him a few additional
c turns to get frantic before we close. when clock2 hits zero, we branch to
c 11000 to transport him into the final puzzle. note that the puzzle depends
c upon all sorts of random things. for instance, there must be no water or
c oil, since there are beanstalks which we don't want to be able to water,
c since the code can't handle it. also, we can have no keys, since there is a
c grate (having moved the fixed object!) there separating him from all the
c treasures. most of these problems arise from the use of negative prop
c numbers to suppress the object descriptions until he's actually moved the
c objects.
c when the first warning comes, we lock the grate, destroy the bridge, kill
c all the dwarves (and the pirate), remove the troll and bear (unless dead),
c and set "closng" to true. leave the dragon; too much trouble to move it.
c from now until clock2 runs out, he cannot unlock the grate, move to any
c location outside the cave (loc<9), or create the bridge. nor can he be
c resurrected if he dies. note that the snake is already gone, since he got
c to the treasure accessible only via the hall of the mt. king. also, he's
c been in giant room (to get eggs), so we can refer to it. also also, he's
c gotten the pearl, so we know the bivalve is an oyster. *and*, the dwarves
c must have been activated, since we've found chest.
10000 prop(grate)=0
prop(fissur)=0
do 10010 i=1,6
dseen(i)=0
10010 dloc(i)=0
call move(troll,0)
call move(troll+100,0)
call move(troll2,plac(troll))
call move(troll2+100,fixd(troll))
call juggle(chasm)
if(prop(bear).ne.3)call dstroy(bear)
prop(chain)=0
fixed(chain)=0
prop(axe)=0
fixed(axe)=0
call rspeak(129)
clock1=-1
closng=1
goto 19999
c once he's panicked, and clock2 has run out, we come here to set up the
c storage room. the room has two locs, hardwired as 115 (ne) and 116 (sw).
c at the ne end, we place empty bottles, a nursery of plants, a bed of
c oysters, a pile of lamps, rods with stars, sleeping dwarves, and him. and
c the sw end we place grate over treasures, snake pit, covey of caged birds,
c more rods, and pillows. a mirror stretches across one wall. many of the
c objects come from known locations and/or states (e.g. the snake is known to
c have been destroyed and needn't be carried away from its old "place"),
c making the various objects be handled differently. we also drop all other
c objects he might be carrying (lest he have some which could cause trouble,
c such as the keys). we describe the flash of light and trundle back.
11000 prop(bottle)=put(bottle,115,1)
prop(plant)=put(plant,115,0)
prop(oyster)=put(oyster,115,0)
prop(lamp)=put(lamp,115,0)
prop(rod)=put(rod,115,0)
prop(dwarf)=put(dwarf,115,0)
loc=115
oldloc=115
newloc=115
c leave the grate with normal (non-negative property).
foo=put(grate,116,0)
prop(snake)=put(snake,116,1)
prop(bird)=put(bird,116,1)
prop(cage)=put(cage,116,0)
prop(rod2)=put(rod2,116,0)
prop(pillow)=put(pillow,116,0)
prop(mirror)=put(mirror,115,0)
fixed(mirror)=116
do 11010 i=1,100
idondx=i
11010 if(toting(idondx).eq.1)call dstroy(idondx)
call rspeak(132)
closed=1
goto 2
c another way we can force an end to things is by having the lamp give out.
c when it gets close, we come here to warn him. we go to 12000 if the lamp
c and fresh batteries are here, in which case we replace the batteries and
c continue. 12200 is for other cases of lamp dying. 12400 is when it goes
c out, and 12600 is if he's wandered outside and the lamp is used up, in which
c case we force him to give up.
12000 call rspeak(188)
prop(batter)=1
if(toting(batter).eq.1)call drop(batter,loc)
limit=limit+2500
lmwarn=0
goto 19999
12200 if(lmwarn.eq.1.or.here(lamp).eq.0)goto 19999
lmwarn=1
spk=187
if(place(batter).eq.0)spk=183
if(prop(batter).eq.1)spk=189
call rspeak(spk)
goto 19999
12400 limit=-1
prop(lamp)=0
if(here(lamp).eq.1)call rspeak(184)
goto 19999
12600 call rspeak(185)
gaveup=1
goto 20000
c oh dear, he's disturbed the dwarves.
19000 call rspeak(136)
c exit code. will eventually include scoring. for now, however, ...
c the present scoring algorithm is as follows:
c objective: points: present total possible:
c getting well into cave 45 45
c each treasure < chest 12 60
c treasure chest itself 14 14
c each treasure > chest 16 144
c surviving (max-num)*10 30
c not quitting 4 4
c reaching "closng" 25 25
c "closed": quit/killed 10
c klutzed 25
c wrong way 30
c success 45 45
c came to witt's end 1 1
c round out the total 2 2
c total: 370
c (points can also be deducted for using hints.)
20000 score=0
mxscor=0
c first tally up the treasures. must be in building and not broken.
c give the poor guy 2 points just for finding each treasure.
do 20010 i=50,maxtrs
if(ptext(i).eq.0)goto 20010
k=12
if(i.eq.chest)k=14
if(i.gt.chest)k=16
if(prop(i).ge.0)score=score+2
if(place(i).eq.3.and.prop(i).eq.0)score=score+k-2
mxscor=mxscor+k
20010 continue
c now look at how he finished and how far he got. maxdie and numdie tell us
c how well he survived. gaveup says whether he exited via quit. dflag will
c tell us if he ever got suitably deep into the cave. closng still indicates
c whether he reached the endgame. and if he got as far as "cave closed"
c (indicated by "closed"), then bonus is zero for mundane exits or 133, 134,
c 135 if he blew it (so to speak).
score=score+(maxdie-numdie)*10
mxscor=mxscor+maxdie*10
if(scorng.eq.0.and.gaveup.eq.0)score=score+4
mxscor=mxscor+4
if(dflag.ne.0)score=score+45
mxscor=mxscor+45
if(closng.eq.1)score=score+25
mxscor=mxscor+25
if(closed.eq.0)go to 20020
if(bonus.eq.0)score=score+10
if(bonus.eq.135)score=score+25
if(bonus.eq.134)score=score+30
if(bonus.eq.133)score=score+45
20020 mxscor=mxscor+45
c did he come to witt's end as he should?
if(place(magzin).eq.108)score=score+1
mxscor=mxscor+1
c round it off.
score=score+2
mxscor=mxscor+2
c deduct points for hints. hints < 4 are special; see database description.
do 20030 i=1,hntmax
20030 if(hinted(i).eq.1)score=score-hints(i,2)
c return to score command if that's where we came from.
if(scorng.eq.1)goto 8241
c that should be good enough. let's tell him all about it.
write (*,20100) score, mxscor, turns
20100 format(///' You scored',i4,' out of a possible',i4,
. ', using',i5,' turns.')
do 20200 i=1,clsses
if(cval(i).ge.score)goto 20210
20200 continue
write (*,20202)
20202 format(/' You just went off my scale !! (Whoops) !!'/)
goto 25000
20210 call speak(ctext(i))
if(i.eq.clsses-1)goto 20220
k=cval(i)+1-score
iz='s. '
if(k.eq.1)iz='. '
write (*,20212) k, iz
20212 format(/' To achieve the next higher rating, you need',i3,
. ' more point',a2/)
goto 25000
20220 write (*,20222)
20222 format(/' To achieve the next higher rating ',
. 'would be a neat trick, Oh Great One!!'//' Congratulations!!'/)
25000 write (*,25001)
25001 format (/////)
pause 'Please Press the ENTER Key to Exit From Adventure.'
end
c
c subroutines and functions
subroutine speak(n)
c print the message which starts at lines(n). precede it with a blank line
c unless blklin is false.
implicit integer*2 (a-z)
common /lincom/ lines
common /txtcom/ rtext
common /blkcom/ blklin
dimension rtext (205)
character*2 lines (21150)
character*2 np,clines
integer*4 nnn,k,l,i
equivalence (clines,ilines)
data np/'>$'/
nnn=n
if(nnn.eq.0)return
if(lines(nnn+1).eq.np)return
if(blklin.eq.1) write (*,2)
k=nnn
1 clines=lines(k)
l=iabs(ilines)-1
k=k+1
write (*, 2) (lines(i),i=k,l)
2 format(' ',36a2)
k=l+1
clines=lines(k)
if(ilines.ge.0) go to 1
return
end
subroutine pspeak(msg,skip)
c find the skip+1st message from msg and print it. msg should be the index of
c the inventory message for object. (inven+n+1 message is prop=n message).
implicit integer*2 (a-z)
common /lincom/ lines
common /txtcom/ rtext
common /ptxcom/ ptext
character*2 lines (21150),clines
dimension rtext(205),ptext(100)
integer*4 mm
equivalence (clines,ilines)
m=ptext(msg)
if(skip.lt.0)goto 9
do 3 i=1,skip+1
1 mm=m
clines=lines(mm)
m=iabs(ilines)
mm=m
clines=lines(mm)
if(ilines.ge.0) go to 1
3 continue
9 call speak(m)
return
end
subroutine rspeak(i)
c print the i-th "random" message (section 6 of database).
implicit integer*2 (a-z)
common /txtcom/ rtext
dimension rtext(205)
if(i.ne.0)call speak(rtext(i))
return
end
integer*2 function yes(x,y,z)
c call yesx (below) with messages from section 6.
implicit integer*2 (a-z)
yes=yesx(x,y,z)
return
end
integer*2 function yesx(x,y,z)
c print message x, wait for yes/no answer. if yes, print y and leave yea
c true; if no, print z and leave yea false.
implicit integer*2 (a-z)
character*4 reply,junk1,junk2,junk3
1 if(x.ne.0) call rspeak (x)
call getin(reply,junk1,junk2,junk3)
if(reply.eq.'yes '.or.reply.eq.'y ')goto 10
if(reply.eq.'no '.or.reply.eq.'n ')goto 20
write (*,9)
9 format(/' Please answer the question "yes" or "no".')
goto 1
10 yesx=1
if(y.ne.0) call rspeak (y)
return
20 yesx=0
if(z.ne.0) call rspeak (z)
return
end
subroutine a5toa1 (a, b, c, d, chars, leng)
c a & b contain a 1 to 8-character word in a4 format. c & d contain
c another word and/or punctuation. they are unpacked to one character
c per word in the array "chars", with exactly one blank between b & c
c (or none, if c is zero). the index of the last non-blank character
c in chars is returned in leng.
implicit integer*2 (a-z)
integer*4 ic
character *20 aaa
character *4 a,b,c,d,aa(5),cc
character *1 chars(20),raw(20)
equivalence (aaa,aa),(cc,ic)
c do first word until a blank
aa(1) = a
aa(2) = b
call unpack (aaa, raw)
c clear output array and move, counting to first blank
leng=0
do 2 i=1,20
2 chars(i)=' '
do 1 i=1,8
if (raw(i).eq.' ') go to 3
chars(i)=raw(i)
1 leng=i
c leng doesn't include trailing blank
3 cc=c
if(ic.eq.0) go to 99
c second word--ignore leading blanks, stop at trailing one
chars(leng+1)=' '
leng=leng+1
ll=leng
aa(1)=c
aa(2)=d
call unpack (aaa,raw)
c skip leading blank if any
do 4 j=1,8
4 if (raw(j).ne.' ') go to 5
c second word was all blank--fooey
go to 99
c do non-blanks
5 do 6 k=j,8
if (raw(k).eq.' ') go to 99
chars (k-j+1+ll) = raw(k)
6 leng=leng+1
99 return
end
c
integer*2 function vocab(id,init)
c look up id in the vocabulary (atab) and return its "definition" (ktab), or
c -1 if not found. if init is positive, this is an initialization call setting
c up a keyword variable, and not finding it constitutes a bug. it also means
c that only ktab values which taken over 1000 equal init may be considered.
c (thus "steps", which is a motion verb also, may be considered
c as an object.) and it also means the ktab value is taken mod 1000.
implicit integer*2 (a-z)
common /voccom/ ktab,atab,tabsiz
character*4 atab(295),id
dimension ktab(295)
do 1 i=1,tabsiz
if(ktab(i).eq.-1)goto 2
if(init.ge.0.and.ktab(i)/1000.ne.init)goto 1
if(atab(i).eq.id)goto 3
1 continue
10 format(1x,i4,2x,a4)
call bug(21)
2 vocab=-1
if(init.lt.0)return
write (*,10) init, id
call bug(5)
3 vocab=ktab(i)
if(init.ge.0)vocab=mod(vocab,1000)
return
end
subroutine dstroy(object)
c permanently eliminate "object" by moving to a non-existent location.
implicit integer*2 (a-z)
call move(object,0)
return
end
subroutine juggle(object)
c juggle an object by picking it up and putting it down again, the purpose
c being to get the object to the front of the chain of things at its loc.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
i=place(object)
call move(object,i)
call move(object+100,j)
return
end
subroutine move(object,where)
c place any object anywhere by picking it up and dropping it. may already be
c toting, in which case the carry is a no-op. mustn't pick up objects which
c are not at any loc, since carry wants to remove objects from atloc chains.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 1
from=place(object)
goto 2
1 from=fixed(object-100)
2 if(from.gt.0.and.from.le.300)call carry(object,from)
call drop(object,where)
return
end
integer*2 function put(object,where,pval)
c put is the same as move, except it returns a value used to set up the
c negated prop values for the repository objects.
implicit integer*2 (a-z)
call move(object,where)
put=(-1)-pval
return
end
subroutine carry(object,where)
c start toting an object, removing it from the list of things at its former
c location. incr holdng unless it was already being toted. if object>100
c (moving "fixed" second loc), don't change place or holdng.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 5
if(place(object).eq.-1)return
place(object)=-1
holdng=holdng+1
5 if(atloc(where).ne.object)goto 6
atloc(where)=link(object)
return
6 temp=atloc(where)
7 if(link(temp).eq.object)goto 8
temp=link(temp)
goto 7
8 link(temp)=link(object)
return
end
subroutine drop(object,where)
c place an object at a given loc, prefixing it onto the atloc list. decr
c holdng if the object was being toted.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 1
if(place(object).eq.-1)holdng=holdng-1
place(object)=where
goto 2
1 fixed(object-100)=where
2 if(where.le.0)return
link(object)=atloc(where)
atloc(where)=object
return
end
c utility routines (shift, ran, datime, bug)
integer*2 function shift (val, dist)
c return val shifted (left if dist>0, else right) dist bits
implicit integer*2 (a-z)
shift=val
if (dist.eq.0) go to 20
idist=iabs(dist)
do 1 i = 1,idist
if (dist.lt.0) shift=shift/2
1 if (dist.gt.0) shift=shift*2
20 return
end
subroutine bug(num)
implicit integer*2 (a-z)
c the following conditions are currently considered fatal bugs. numbers < 20
c are detected while reading the database; the others occur at "run time".
c 0 message line > 72 characters
c 1 null line in message * Only ones
c 2 too many words of messages currently
c 3 too many travel options implemented
c 4 too many vocabulary words
c 5 * required vocabulary word not found
c 6 too many rtext messages
c 7 too many hints
c 8 location has cond bit being set twice
c 9 invalid section number in database
c 20 * special travel (500>l>300) exceeds goto list
c 21 * ran off end of vocabulary table
c 22 * vocabulary type (n/1000) not between 0 and 3
c 23 * intransitive action verb exceeds goto list
c 24 transitive action verb exceeds goto list
c 25 * conditional travel entry with no alternative
c 26 * location has no travel entries
c 27 * hint number exceeds goto list
c 28 invalid month returned by date function
write (*,1) num
1 format (' Fatal error, see source code for interpretation.'/
. ' Probable cause: erroneous info in database.'/
2 ' Error code =',i2/)
pause 'To Exit From Adventure'
end
subroutine getin (word1,word1x,word2,word2x)
c get a command from the adventurer. snarf out the first word, pad it
c with blanks, and return in word1--word1x used for overflow charcters
c 5-8 in case we need to print the whole word back out in an error.
c any number of blanks may follow the word. if a second word appears
c it is returned in word2/word2x, else word2 is set to zero. all are
c converted to lower case for comparison ease (ibm pc version).
implicit integer*2 (a-z)
common /blkcom/ blklin
character*1 s(20), t(20)
character*4 word1, word1x, word2, word2x, w1(5), w2(5), a(5)
character*20 w81, w82, aa, bb
integer*4 iw1, iw1x, iw2, iw2x
equivalence (w1(1),iw1),(w1(2),iw1x),(a,aa)
equivalence (w2(1),iw2),(w2(2),iw2x),(w81,w1),(w82,w2)
if (blklin.eq.1) write (*,1)
1 format (1x)
c give a prompt to make him think we want input
write (*,9)
9 format (' -> ',\)
c
c read twenty characters into a. unpack them into s.
read (*,3) a
3 format (5a4)
bb = aa
call unpack (bb, s)
c translate all to lower case
do 1001 i=1,20
if (ichar(s(i)).lt.65.or.ichar(s(i)).gt.90) go to 1001
s(i)=char(ichar(s(i))+32)
1001 continue
c go through the characters and transfer the first word into t, up
c to eight characters
do 10 i=1,20
10 t(i)=' '
do 11 i=1,8
if (s(i).eq.' ') go to 20
11 t(i)=s(i)
c now repack the characters into w81, equivalent to word1,word1x
20 call pack (w81,t)
word1=w1(1)
word1x=w1(2)
c now find a second word if one exists--clear return words first
iw2=0
iw2x=0
do 30 i=1,20
30 t(i)=' '
do 31 i=1,20
if (s(i).ne.' ') go to 31
go to 32
31 continue
c all characters--fooey
go to 40
c hit first blank after first word--now get first non-blank
32 do 33 j=i,20
if (s(j).eq.' ') go to 33
go to 34
33 continue
c blanked out again
go to 40
c hit beginning of second word--finish it
34 do 35 i=j,20
if (s(i).eq.' ') go to 36
35 t(i-j+1)=s(i)
c now repack word2/2x
36 call pack (w82,t)
40 word2=w2(1)
word2x=w2(2)
return
end
c
subroutine unpack (b, s)
implicit integer*2 (a-z)
c unpack general subroutine
c b 20 character string
c s 20 character*1 singles
character*20 a,b
character*4 aa(5)
integer*4 ia(5)
equivalence (ia,a,aa)
character*1 s(20)
a = b
do 1 k = 1,5
do 1 j = 1,4
s(4*(k-1)+j)=aa(k)
1 if(j.ne.4)ia(k)=ia(k)/256
return
end
c
subroutine pack (b, t)
implicit integer*2 (a-z)
c general pack subroutine--20 characters
c b return packed word--20
c t array to pack of char*1's
character*20 a,b
integer*4 ia(5)
equivalence (ia,a)
character*1 s(20),t(20)
do 95 i = 1,20
95 s(i)=t(i)
do 1 k = 1,5
ia(6-k)=0
do 1 j = 1, 4
l=4*(5-k)+5-j
ia(6-k) = ia(6-k) + ichar (s(l))
1 if (j.ne.4) ia(6-k) = ia(6-k) * 256
b=a
return
end
c
integer*2 function toting(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
toting=0
if (place(obj).eq.-1) toting=1
return
end
c
integer*2 function here(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
common /loccom/ loc
dimension atloc(150),link(200),place( 100),fixed(100)
here=0
if (place(obj).eq.loc.or.toting(obj).eq.1) here=1
return
end
c
integer*2 function at(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
common /loccom/ loc
dimension atloc(150),link(200),place( 100),fixed(100)
at=0
if (place(obj).eq.loc.or.fixed(obj).eq.loc) at=1
return
end
c
integer*2 function forced(loc)
implicit integer*2 (a-z)
common /concom/ cond
dimension cond (150)
forced=0
if (cond(loc).eq.2) forced=1
return
end
c
integer*2 function dark(dummy)
implicit integer*2 (a-z)
common /concom/ cond
common /loccom/ loc
common /procom/ prop, lamp
dimension cond(150),prop(100)
external here
dark=0
if (mod(cond(loc),2).eq.0 .and. (prop(lamp).eq.0 .or.
. here(lamp).eq.0)) dark=1
return
end
c
integer*2 function pct(n)
implicit integer*2 (a-z)
external ran
pct=0
if (ran(100).lt.n) pct=1
return
end
subroutine datime (daye,t)
c d is date as number of days (more or less) after jan 1 77
c t is time as number of minutes past midnight
implicit integer*4 (a-z)
call getdat(year,month,day)
call gettim(hour,minute,second,hndrth)
t=minute+60*hour
daye=(year-77)*365+((month-1)*30)+day
return
end
integer*2 function ran(range)
c since the ran function in lib40 seems to be a real lose, we'll use one of
c our own. it's been run through many of the tests in knuth vol. 2 and
c seems to be quite reliable. ran returns a value uniformly selected
c between 0 and range-1. note resemblance to alg used in wizard.
implicit integer*4 (a-z)
integer*2 range
data r/-1/
d=1
if(r.ne.-1)goto 1
call datime(d,t)
r=18*t+5
d=1000+mod(d,1000)
1 do 2 t=1,d
2 r=mod(r*1021,1048576)
rn=(range*r)/1048576
ran=rn
return
end
c ======= end =======